{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Base.Overloading
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- 
--
--------------------------------------------------------------------------------


module Lirio.Base.Overloading
  (

    Ust
  , UserStateM(..)
  , modify

  , HasNewlineM(..)
  , HasCommandM(..)

  , NoteListM


  , GenericMarkM(..)
  , GenericEventM(..)

  , HasRestM(..)
  , HasSpacerM(..)

  , Pch
  , NoteM(..)
  , ChordM(..)

  , GroupingM(..)
  , beaml
  , beamr
  , beam

  ) where

import Lirio.Base.Duration

import Text.PrettyPrint.Leijen                  -- package: wl-pprint


type family Ust (m :: * -> *) :: *


class Monad m => UserStateM m where
  get :: i ~ Ust m => m i 
  set :: i ~ Ust m => i -> m ()


modify :: (UserStateM m, st ~ Ust m) => (st -> st) -> m ()
modify f = get >>= (set . f)


-- | Both scores and notelists have newline and commands ...
--
class Monad m => HasNewlineM m where
  newline :: m ()

class Monad m => HasCommandM m where
  command :: String -> m ()


class (HasNewlineM m, HasCommandM m) => NoteListM m 


class (NoteListM m) => GenericMarkM m where
  genericMark :: Doc -> m ()

class (NoteListM m) => GenericEventM m where
  genericEvent :: Doc -> Duration -> m ()
  


class (GenericEventM m) => HasRestM m where
  rest :: Duration -> m ()
  rest = genericEvent (char 'r') 


class (GenericEventM m) => HasSpacerM m where
  spacer :: Duration -> m ()
  spacer = genericEvent (char 's') 



-- A class for notes should have a unique determination of
-- \"pitch\" for any note list.
-- 
-- Similarly for chords...
--

type family Pch (m :: * -> *) :: *

class (GenericEventM m) => NoteM m where
  note :: pch ~ Pch m => pch -> Duration -> m ()

class NoteM m => ChordM m where
  chord :: pch ~ Pch m => [pch] -> Duration -> m ()


-- | Note - prefix and suffix are transformers not elementary
-- documents.
--
class (NoteListM m) => GroupingM m where
  prefix :: Doc -> m a -> m a
  suffix :: Doc -> m a -> m a

beaml :: GroupingM m => m a -> m a
beaml = prefix (char '[')

beamr :: GroupingM m => m a -> m a
beamr = suffix (char ']')

beam :: GroupingM m => m a -> m a
beam = beamr . beaml